module collections use iso_fortran_env implicit none private public :: list public :: linked_list ! ------------------------------------------------------------------------------ integer(int32), parameter :: FL_NO_ERROR = 0 integer(int32), parameter :: FL_INVALID_ARGUMENT_ERROR = 1000 integer(int32), parameter :: FL_OUT_OF_MEMORY_ERROR = 1001 integer(int32), parameter :: FL_INDEX_OUT_OF_RANGE_ERROR = 1002 integer(int32), parameter :: FL_INVALID_ITERATOR_ERROR = 1003 integer(int32), private, parameter :: DEFAULT_BUFFER_SIZE = 10 ! ------------------------------------------------------------------------------ type container !! A container for an unlimited polymorphic variable allowing storage !! of any type. class(*), private, pointer :: m_item => null() ! The pointer to the stored item. logical, private :: m_delete = .true. ! Set to true to delete m_item when this container object goes out ! of scope; else, set to false to persist. contains procedure, public :: get => c_get procedure, public :: delete_on_cleanup => c_get_delete final :: c_destroy procedure, public :: free => c_cleanup end type ! ------------------------------------------------------------------------------ type, extends(container) :: node ! A node in a linked list container. type(node), private, pointer :: next => null() ! A pointer to the next node in the collection. type(node), private, pointer :: previous => null() ! A pointer to the previous node in the collection. end type ! ------------------------------------------------------------------------------ type list !! Defines a generic, dynamically sizable list. type(container), private, allocatable, dimension(:) :: m_list ! A collection of container objects. integer(int32), private :: m_count = 0 ! The actual number of items in m_list. contains procedure, public :: count => list_get_count procedure, public :: get_capacity => list_get_capacity procedure, public :: set_capacity => list_set_capacity procedure, public :: push => list_push procedure, public :: pop => list_pop procedure, public :: get => list_get procedure, public :: set => list_set procedure, public :: insert => list_insert procedure, public :: remove => list_remove procedure, public :: clear => list_clear end type ! ------------------------------------------------------------------------------ type linked_list !! Defines a generic, linked-list container. integer(int32), private :: m_count = 0 ! The number of nodes in the container. type(node), private, pointer :: m_first => null() ! A pointer to the first node in the container. type(node), private, pointer :: m_last => null() ! A pointer to the last node in the container. type(node), private, pointer :: m_current => null() ! A pointer to the current node selected by the user. contains procedure, public :: count => ll_count procedure, public :: move_to_first => ll_move_to_first procedure, public :: move_to_last => ll_move_to_last procedure, public :: next => ll_move_to_next procedure, public :: previous => ll_move_to_previous procedure, public :: get => ll_get procedure, public :: set => ll_set procedure, public :: push => ll_push procedure, public :: pop => ll_pop procedure, public :: clear => ll_clear final :: ll_destroy end type contains ! ****************************************************************************** ! CONTAINER MEMBERS ! ------------------------------------------------------------------------------ function c_get(this) result(rst) !! Gets a pointer to the stored unlimited polymorphic object. class(container), intent(in) :: this !! The [[container]] object. class(*), pointer :: rst !! The requested pointer. rst => this%m_item end function ! ------------------------------------------------------------------------------ pure function c_get_delete(this) result(rst) !! Gets a value determining if the object should clean up after itself !! by freeing the resources allocated by the stored object when this !! container goes out of scope. class(container), intent(in) :: this !! The [[container]] object. logical :: rst !! Returns true if the stored item will be cleaned up; else, !! false denoting the item will persist. rst = this%m_delete end function ! ------------------------------------------------------------------------------ subroutine c_destroy(this) !! Frees the resources held by the stored item. type(container), intent(inout) :: this !! The [[container]] object. call this%free() end subroutine ! ------------------------------------------------------------------------------ subroutine c_cleanup(this) !! Frees the resources held by the stored item. class(container), intent(inout) :: this !! The [[container]] object. if (this%delete_on_cleanup() .and. associated(this%m_item)) then deallocate(this%m_item) nullify(this%m_item) else nullify(this%m_item) end if end subroutine ! ****************************************************************************** ! LIST MEMBERS ! ------------------------------------------------------------------------------ pure function list_get_count(this) result(rst) !! Gets the number of items stored in the list. class(list), intent(in) :: this !! The [[list]] object. integer(int32) :: rst !! The number of items stored in the list. rst = this%m_count end function ! ------------------------------------------------------------------------------ pure function list_get_capacity(this) result(rst) !! Gets the capacity of the list. !! !! The capacity is the available "space" in the collection for adding !! additional items without resizing the internal data store. This !! capacity includes the currently utilized space. To obtain a count !! of the actual number of items stored in the list use the count !! routine. class(list), intent(in) :: this !! The [[list]] object. integer(int32) :: rst !! The capacity of the list. if (allocated(this%m_list)) then rst = size(this%m_list) else rst = 0 end if end function ! ------------------------------------------------------------------------------ subroutine list_set_capacity(this, n) !! Sets the capacity of the list. !! !! The capacity is the available "space" in the collection for adding !! additional items without resizing the internal data store. This !! capacity includes the currently utilized space. To obtain a count !! of the actual number of items stored in the list use the count !! routine. class(list), intent(inout) :: this !! The [[list]] object. integer(int32), intent(in) :: n !! The new capacity of the list. This value must be greater than or !! equal to 1. ! Local Variables integer(int32) :: m type(container), allocatable :: copy(:) ! Initialization m = this%count() ! Input Check if (n < 1) error stop FL_INVALID_ARGUMENT_ERROR ! Quick Return if (m == n) return ! Process if (.not.allocated(this%m_list)) then allocate(this%m_list(n)) end if if (n > m) then ! Increase capacity call move_alloc(this%m_list, copy) allocate(this%m_list(n)) this%m_list(1:m) = copy(1:m) else ! Decrease capacity allocate(copy(n), source = this%m_list(1:n)) call move_alloc(copy, this%m_list) this%m_count = n end if end subroutine ! ------------------------------------------------------------------------------ subroutine list_push(this, x, manage) !! Pushes an item onto the back of the list. class(list), intent(inout) :: this !! The [[list]] object. class(*), intent(in), target :: x !! The object to store. logical, intent(in), optional :: manage !! An optional input used to determine if the list should manage !! memory for this object. If set to true a clone of x is stored and !! the list will handle management of resources held by the clone. If !! false, the list will not manage resources held by x and x itself !! will be stored. Notice, in this manner it is possible for x to go !! out of scope while the list still persists thereby resulting in a !! potentially undefined behavior. It is recommended to use the !! default value of true except for very specific and well controlled !! edge cases. ! Local Variables integer(int32) :: index, cap ! Initialization index = this%count() + 1 cap = this%get_capacity() ! Ensure there's space for the item if ((cap == 0) .or. & (cap - index <= 0)) & then ! We need more room call this%set_capacity(cap + DEFAULT_BUFFER_SIZE) end if ! Store the item this%m_count = index ! must be before the set routine call this%set(index, x, manage) end subroutine ! ------------------------------------------------------------------------------ subroutine list_pop(this) !! Pops the last item off the back of the list. class(list), intent(inout) :: this !! The [[list]] object. ! Process integer(int32) :: index index = this%count() if (index == 0) return call this%m_list(index)%free() this%m_count = index - 1 end subroutine ! ------------------------------------------------------------------------------ function list_get(this, i) result(rst) !! Gets the requested item from the list. class(list), intent(in) :: this !! The [[list]] object. integer(int32), intent(in) :: i !! The one-based index of the item to retrieve. class(*), pointer :: rst !! A pointer to the requested object. ! Initialization nullify(rst) ! Input Check if (i < 1 .or. i > this%count()) then error stop FL_INDEX_OUT_OF_RANGE_ERROR end if ! Process rst => this%m_list(i)%get() end function ! ------------------------------------------------------------------------------ subroutine list_set(this, i, x, manage) !! Sets the specified item into the list. class(list), intent(inout) :: this !! The [[list]] object. integer(int32), intent(in) :: i !! The one-based index defining where to put the item. class(*), intent(in), target :: x !! The object to store. logical, intent(in), optional :: manage !! An optional input used to determine if the list should manage !! memory for this object. If set to true a clone of x is stored and !! the list will handle management of resources held by the clone. If !! false, the list will not manage resources held by x and x itself !! will be stored. Notice, in this manner it is possible for x to go !! out of scope while the list still persists thereby resulting in a !! potentially undefined behavior. It is recommended to use the !! default value of true except for very specific and well controlled !! edge cases. ! Local Variables logical :: mng class(*), pointer :: clone ! Initialization mng = .true. if (present(manage)) mng = manage ! Input Check if (i < 1 .or. i > this%count()) then error stop FL_INDEX_OUT_OF_RANGE_ERROR end if ! Store the item call this%m_list(i)%free() if (mng) then this%m_list(i)%m_delete = .true. allocate(clone, source = x) this%m_list(i)%m_item => clone else this%m_list(i)%m_delete = .false. this%m_list(i)%m_item => x end if end subroutine ! ------------------------------------------------------------------------------ subroutine list_insert(this, i, x, manage) !! Inserts an item into the list. class(list), intent(inout) :: this !! The [[list]] object. integer(int32) :: i !! The one-based index defining where to put the item. class(*), intent(in) :: x !! The object to store. logical, intent(in), optional :: manage !! An optional input used to determine if the list should manage !! memory for this object. If set to true a clone of x is stored and !! the list will handle management of resources held by the clone. If !! false, the list will not manage resources held by x and x itself !! will be stored. Notice, in this manner it is possible for x to go !! out of scope while the list still persists thereby resulting in a !! potentially undefined behavior. It is recommended to use the !! default value of true except for very specific and well controlled !! edge cases. ! Local Variables logical :: mng integer(int32) :: j, n ! Initialization mng = .true. if (present(manage)) mng = manage n = this%count() ! Input Checking if (i < 1 .or. i > n + 1) then error stop FL_INDEX_OUT_OF_RANGE_ERROR end if ! Ensure there's capacity if (this%get_capacity() <= n + 1) then call this%set_capacity(n + DEFAULT_BUFFER_SIZE) end if ! Shift everything back by one element and insert the item this%m_count = this%m_count + 1 do j = n, i, -1 call this%set(j + 1, this%get(j), mng) end do call this%set(i, x, mng) end subroutine ! ------------------------------------------------------------------------------ subroutine list_remove(this, i) !! Removes an item from the list. class(list), intent(inout) :: this !! The [[list]] object. integer(int32) :: i !! The one-based index defining which item to remove. ! Local Variables integer(int32) :: n ! Initialization n = this%count() ! Quick Return if (n == 0) return ! Input Checking if (i < 1 .or. i > n) then error stop FL_INDEX_OUT_OF_RANGE_ERROR end if ! Process if (n == 1) then call this%clear() else call this%m_list(i)%free() this%m_list(i:n-1) = this%m_list(i+1:n) this%m_count = this%m_count - 1 end if end subroutine ! ------------------------------------------------------------------------------ subroutine list_clear(this) !! Clears the entire list. class(list), intent(inout) :: this !! The [[list]] object. ! Local Variables integer(int32) :: i, n ! Process n = this%count() do i = 1, n call this%m_list(i)%free() end do this%m_count = 0 end subroutine ! ****************************************************************************** ! LINKED_LIST MEMBERS ! ------------------------------------------------------------------------------ pure function ll_count(this) result(rst) !! Gets the number of items in the list. class(linked_list), intent(in) :: this !! The [[linked_list]] object. integer(int32) :: rst rst = this%m_count end function ! ------------------------------------------------------------------------------ subroutine ll_move_to_first(this) !! Moves the current position in the list to the first item. class(linked_list), intent(inout) :: this !! The [[linked_list]] object. if (associated(this%m_first)) then this%m_current => this%m_first end if end subroutine ! ------------------------------------------------------------------------------ subroutine ll_move_to_last(this) !! Moves the current position in the list to the last item. class(linked_list), intent(inout) :: this !! The [[linked_list]] object. if (associated(this%m_last)) then this%m_current => this%m_last end if end subroutine ! ------------------------------------------------------------------------------ function ll_move_to_next(this) result(rst) !! Moves to the next item in the list. class(linked_list), intent(inout) :: this !! The [[linked_list]] object. logical :: rst !! Returns true if the move was successful; else, returns false. !! Typically a false value indicates the end of the list; however, a !! false value can be encountered if the list is emtpy. ! Process if (.not.associated(this%m_current)) then rst = .false. return end if if (associated(this%m_current%next)) then this%m_current => this%m_current%next rst = .true. else rst = .false. end if end function ! ------------------------------------------------------------------------------ function ll_move_to_previous(this) result(rst) !! Moves to the previous item in the list. class(linked_list), intent(inout) :: this !! The [[linked_list]] object. logical :: rst !! Returns true if the move was successful; else, returns false. !! Typically a false value indicates the end of the list; however, a !! false value can be encountered if the list is emtpy. ! Process if (.not.associated(this%m_current)) then rst = .false. return end if if (associated(this%m_current%previous)) then this%m_current => this%m_current%previous rst = .true. else rst = .false. end if end function ! ------------------------------------------------------------------------------ function ll_get(this) result(rst) !! Gets the current item. class(linked_list), intent(in) :: this !! The [[linked_list]] object. class(*), pointer :: rst !! The currently referenced item from the list. This may be !! null if the list is empty. ! Process if (associated(this%m_current)) then rst => this%m_current%get() else rst => null() end if end function ! ------------------------------------------------------------------------------ subroutine ll_set(this, x, manage) !! Replaces the current item in the list with the supplied item. class(linked_list), intent(inout) :: this !! The [[linked_list]] object. class(*), intent(in), target :: x !! The object to store. logical, intent(in), optional :: manage !! An optional input used to determine if the list should manage !! memory for this object. If set to true a clone of x is stored and !! the list will handle management of resources held by the clone. If !! false, the list will not manage resources held by x and x itself !! will be stored. Notice, in this manner it is possible for x to go !! out of scope while the list still persists thereby resulting in a !! potentially undefined behavior. It is recommended to use the !! default value of true except for very specific and well controlled !! edge cases. ! Local Variables logical :: mng class(*), pointer :: clone ! Initialization mng = .true. if (present(manage)) mng = manage ! Ensure we're at a valid node if (.not.associated(this%m_current)) then error stop FL_INVALID_ITERATOR_ERROR end if ! Process call this%m_current%free() if (mng) then allocate(clone, source = x) this%m_current%m_item => clone else this%m_current%m_item => x this%m_current%m_delete = .false. end if end subroutine ! ------------------------------------------------------------------------------ subroutine ll_push(this, x, manage) !! Pushes an item onto the end of the list. class(linked_list), intent(inout) :: this !! The [[linked_list]] object. class(*), intent(in), target :: x !! The object to store. logical, intent(in), optional :: manage !! An optional input used to determine if the list should manage !! memory for this object. If set to true a clone of x is stored and !! the list will handle management of resources held by the clone. If !! false, the list will not manage resources held by x and x itself !! will be stored. Notice, in this manner it is possible for x to go !! out of scope while the list still persists thereby resulting in a !! potentially undefined behavior. It is recommended to use the !! default value of true except for very specific and well controlled !! edge cases. ! Local Variables integer(int32) :: n logical :: mng type(node), pointer :: nd, temp, newnode class(*), pointer :: clone ! Initialization n = this%count() mng = .true. if (present(manage)) mng = manage ! Process if (n == 0) then ! This is the first node if (associated(this%m_first)) then ! This shouldn't ever be needed, but is a kind of catch-all call this%m_first%free() deallocate(this%m_first) end if allocate(this%m_first) this%m_first%next => null() this%m_first%previous => null() nd => this%m_first ! As this is the first, it's also the last and the current this%m_last => this%m_first this%m_current => this%m_first else ! We have a new last item allocate(newnode) temp => this%m_last temp%next => newnode this%m_last => newnode this%m_last%previous => temp this%m_last%next => null() nd => this%m_last end if ! Store the item if (mng) then allocate(clone, source = x) nd%m_item => clone else nd%m_item => x nd%m_delete = .false. end if ! Index the count this%m_count = this%m_count + 1 end subroutine ! ------------------------------------------------------------------------------ subroutine ll_pop(this) !! Pops an item off the back of the list. class(linked_list), intent(inout) :: this !! The [[linked_list]] object. ! Local Variables type(node), pointer :: temp ! Quick Return if (this%count() == 0) return if (.not.associated(this%m_last)) return ! Process if (this%count() == 1) then call this%clear() else temp => this%m_last%previous nullify(temp%next) if (associated(this%m_current, this%m_last)) then ! If the iterator is referencing the last item shift it to the ! "new" last item this%m_current => temp end if call this%m_last%free() deallocate(this%m_last) this%m_last => temp this%m_count = this%m_count - 1 end if end subroutine ! ------------------------------------------------------------------------------ subroutine ll_clear(this) !! Clears the entire list. class(linked_list), intent(inout) :: this !! The [[linked_list]] object. ! Local Variables integer(int32) :: i, n type(node), pointer :: currentNode, nextNode ! Initialization n = this%count() ! Quick Return if (n == 0) return ! Process currentNode => this%m_current do i = 1, n if (.not.associated(currentNode)) cycle nextNode => currentNode%next call currentNode%free() deallocate(currentNode) nullify(currentNode) currentNode => nextNode end do this%m_count = 0 nullify(this%m_first) nullify(this%m_last) nullify(this%m_current) end subroutine ! ------------------------------------------------------------------------------ subroutine ll_destroy(this) !! Finalizer for the linked_list type responsible for clean-up duties !! when the list goes out of scope. type(linked_list), intent(inout) :: this !! The [[linked_list]] object. call this%clear() end subroutine ! ------------------------------------------------------------------------------ end module